home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / table.c < prev    next >
C/C++ Source or Header  |  1992-10-26  |  15KB  |  617 lines
  1. /* ******************************************************************** */
  2. /*  table.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  "hash" tables                                                       */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: table.c,v 1.14 1992/08/06 18:15:03 pab Exp $
  9.  *
  10.  * $Log: table.c,v $
  11.  * Revision 1.14  1992/08/06  18:15:03  pab
  12.  * optimised
  13.  *
  14.  * Revision 1.13  1992/05/19  11:27:25  pab
  15.  * fixed for daft compilers
  16.  *
  17.  * Revision 1.12  1992/04/27  22:01:02  pab
  18.  * fixed stackers
  19.  *
  20.  * Revision 1.11  1992/04/21  19:53:24  pab
  21.  * Fixed traverse_table, assuming TCOMPARE allocates.
  22.  *
  23.  * Revision 1.10  1992/01/29  13:50:50  pab
  24.  * vax fix
  25.  *
  26.  * Revision 1.9  1992/01/17  22:32:50  pab
  27.  * fixed hash problemette
  28.  *
  29.  * Revision 1.8  1992/01/10  15:16:24  pab
  30.  * macroised total_hash
  31.  *
  32.  * Revision 1.7  1992/01/09  22:29:09  pab
  33.  * Fixed for low tag ints
  34.  *
  35.  * Revision 1.6  1992/01/07  22:15:46  pab
  36.  * ncc compatable, plus backtrace
  37.  *
  38.  * Revision 1.5  1992/01/05  22:48:29  pab
  39.  * Minor bug fixes, plus BSD version
  40.  *
  41.  * Revision 1.4  1991/12/22  15:14:42  pab
  42.  * Xmas revision
  43.  *
  44.  * Revision 1.3  1991/09/22  19:14:42  pab
  45.  * Fixed obvious bugs
  46.  *
  47.  * Revision 1.2  1991/09/11  12:07:48  pab
  48.  * 11/9/91 First Alpha release of modified system
  49.  *
  50.  * Revision 1.1  1991/08/12  16:50:08  pab
  51.  * Initial revision
  52.  *
  53.  * Revision 1.4  1991/02/14  11:27:51  kjp
  54.  * Boosted table efficiency by inlining eq among other stuff.
  55.  *
  56.  */
  57.  
  58. #define KJPDBG(x) 
  59.  
  60. /*
  61.  * Change Log:
  62.  *   Version 1, April 1989
  63.  *        Syntax fixes - JPff
  64.  *        Name changes - RJB
  65.  *        Fixed the copy functions - KJP ( 17/10/89 )
  66.  *        Arbitrary lisp functions - KJP ( 27/9/90 )
  67.  */
  68.  
  69. /* "Tables provide a general key to value association mechanism.
  70.  *  Operationally, tables resemble hashtables, but the actual
  71.  *  representation is not defined in order to permit alternative
  72.  *  solutions, such as various forms of balanced trees."
  73.  
  74.  * (tablep obj) -> { t | nil }
  75.  * (make-table [comparator]) -> table                comparator is an "equal"
  76.  * (table-parameters table) -> multiple-value
  77.  * (tref table key) -> obj
  78.  * ((set tref) table key obj) -> nil
  79.  * (map-table table function) -> nil
  80.  */
  81.  
  82. /* How about: a "table" is a balanced tree of some sorts: use a VECTOR
  83.  * [key, value, hash, left, right]
  84.  * and use the hash to binary chop.
  85.  */
  86.  
  87. #include "funcalls.h"
  88. #include "defs.h"
  89. #include "structs.h"
  90. #include "error.h"
  91. #include "global.h"
  92. #include "modboot.h"
  93.  
  94. #include "ngenerics.h"
  95.  
  96. #include "calls.h"
  97.  
  98. #define TABLES_ENTRIES 11
  99. MODULE Module_tables;
  100. LispObject Module_tables_values[TABLES_ENTRIES];
  101.  
  102. #define TKEY(node)    vref((node),0)
  103. #define TVALUE(node)  vref((node),1)
  104. #define THASH(node)   intval(vref((node),2))
  105. #define TLEFT(node)   vref((node),3)
  106. #define TRIGHT(node)  vref((node),4)
  107.  
  108. #define total_hash(x) (is_symbol(x)? x->SYMBOL.hash: total_hash_fn(x))
  109.  
  110. /* Comparison with optimisation */
  111.  
  112. #define TCOMPARE(tab,k1,k2) \
  113.           (tab->comparator == Fn_eq \
  114.              ? k1 == k2 \
  115.          : (tab->comparator == NULL \
  116.           ? EUCALL_3(apply2,tab->lisp_comparator,k1,k2) != nil \
  117.           : EUCALL_2((*(tab->comparator)),k1,k2) != nil))
  118.  
  119. /* slow but fun hash from gdbm */
  120.  
  121. int
  122. hash (char *dptr)
  123. {
  124.   int  value;        /* Used to compute the hash value.  */
  125.   int  index;        /* Used to cycle through random values. */
  126.  
  127.  
  128.   /* Set the initial value from key. */
  129.   value = 0x238F13AF;
  130.   for (index = 0; index<10&&dptr[index]!='\0'; index++)
  131.     value = (value + (dptr[index] << (index*5 % 24))) & 0x7FFFFFFF;
  132.  
  133.   value = (1103515243 * value + 12345) & 0x7FFFFFFF;  
  134.  
  135.   /* Return the value. */
  136.   return value;
  137. }
  138.  
  139.  
  140. static int total_hash_fn(LispObject x)
  141. {
  142.   switch (typeof(x)) {
  143.   case TYPE_CLASS:
  144.     x=x->CLASS.name; /* and fall through */
  145.    case TYPE_SYMBOL:
  146.     return x->SYMBOL.hash;
  147.    case TYPE_INT:
  148.     return(intval(x));
  149.    case TYPE_FLOAT:
  150.     return((int) (x->FLOAT.fvalue));
  151.   }
  152.  
  153.   /* No dice - linear search */
  154.  
  155.   return(0); 
  156. }
  157.  
  158. EUFUN_1( Fn_tablep, x)
  159. {
  160.   if (is_table(x)) return lisptrue;
  161.   return nil;
  162. }
  163. EUFUN_CLOSE
  164.  
  165. extern LispObject Gf_equal(LispObject*);
  166.  
  167. EUFUN_1( Fn_make_table, forms)
  168. {
  169.   extern LispObject function_eq;
  170.   struct table_structure* new_table;
  171.  
  172.   if (forms == nil) 
  173.     new_table = &allocate_table(stacktop,Fn_eq)->TABLE;
  174.   else {
  175.     LispObject fn;
  176.  
  177.     fn = CAR(forms);
  178.  
  179.     if (fn == function_eq) 
  180.       new_table = &allocate_table(stacktop,Fn_eq)->TABLE;
  181.     else {
  182.       new_table = &allocate_table(stacktop,NULL)->TABLE;
  183.       new_table->lisp_comparator = CAR(ARG_0(stackbase));
  184.     }
  185.   }
  186.   
  187.   return((LispObject) new_table);
  188. }
  189. EUFUN_CLOSE
  190.  
  191. /* temporary while we work out multiple values */
  192. LispObject table_params_kludge;
  193.  
  194. void cons_up_table_params(LispObject *stacktop, LispObject table)
  195. {
  196.  top:
  197.   if (null(table)) return;
  198.   cons_up_table_params(stacktop,TLEFT(table));
  199.   EUCALLSET_2(table_params_kludge,Fn_cons, TVALUE(table), table_params_kludge);
  200.   table = TRIGHT(table);
  201.   goto top;
  202. }
  203.  
  204. extern void cons_up_table_keys(LispObject*,LispObject);
  205.  
  206. void cons_up_table_keys(LispObject *stacktop, LispObject table)
  207. {
  208.  top:
  209.   if (null(table)) return;
  210.   STACK_TMP(table);
  211.   cons_up_table_keys(stacktop,TLEFT(table));
  212.   UNSTACK_TMP(table);
  213.   STACK_TMP(table);
  214.   EUCALLSET_2(table_params_kludge,Fn_cons, TKEY(table), table_params_kludge);
  215.   UNSTACK_TMP(table);
  216.   table = TRIGHT(table);  
  217.   goto top;
  218. }
  219.  
  220. /* return a multiple value of all the values in the table */
  221. EUFUN_1( Fn_table_parameters, table)
  222. {
  223.   while (!is_table(table))
  224.     table = CallError(stacktop,"table-parameters: ~a is not a table", table,
  225.               CONTINUABLE);
  226.   table_params_kludge = nil;
  227.   cons_up_table_params(stacktop,table->TABLE.tree);
  228.   return table_params_kludge;
  229. }
  230. EUFUN_CLOSE
  231.  
  232. /* Usefull ?? */
  233. EUFUN_1( Fn_table_keys, table)
  234. {
  235.   if (table == nil) return(nil); /* HACK !! */
  236.   table_params_kludge = nil;
  237.   cons_up_table_keys(stacktop,table->TABLE.tree);
  238.   return table_params_kludge;
  239. }
  240. EUFUN_CLOSE
  241.  
  242. /* Look for key in table. Return nil if not found */
  243. static LispObject traverse_table(LispObject *stacktop, struct table_structure* table,
  244.               LispObject key)
  245. {
  246.   LispObject node = nil;
  247.   LispObject tab=(LispObject)table;
  248.   int hashval;
  249.  
  250.   hashval = total_hash(key);
  251.   node = table->tree;
  252.   do {
  253.     if (null(node)) {        /* end of tree - key not found */
  254.       return nil;
  255.     }
  256.     STACK_TMP(tab);
  257.     STACK_TMP(key);
  258.     STACK_TMP(node);
  259.     if (TCOMPARE((&(tab->TABLE)),TKEY(node),key)) {
  260.       UNSTACK_TMP(node);
  261.       return TVALUE(node);
  262.     }
  263.     UNSTACK_TMP(node);
  264.     UNSTACK_TMP(key);
  265.     UNSTACK_TMP(tab);
  266.     if (hashval < THASH(node)) node = TLEFT(node);
  267.     else node = TRIGHT(node);
  268.   } while (TRUE);
  269.  
  270.   return(nil);
  271. }
  272.  
  273. static LispObject traverse_eq_table(LispObject *stacktop, struct table_structure* table,
  274.                     LispObject key)
  275. {
  276.   LispObject node = nil;
  277.   int hashval;
  278.  
  279.   hashval = total_hash(key);
  280.   node = table->tree;
  281.   do {
  282.     if (null(node)) {        /* end of tree - key not found */
  283.       return nil;
  284.     }
  285.  
  286.     if (TKEY(node)==key) {
  287.       return TVALUE(node);
  288.     }
  289.     if (hashval < THASH(node)) node = TLEFT(node);
  290.     else node = TRIGHT(node);
  291.   } while (TRUE);
  292.  
  293.   return(nil);
  294. }
  295.  
  296. EUFUN_2( Fn_tref, table, key)
  297. {
  298.   LispObject ans;
  299.  
  300.   while (!is_table(table))
  301.     table = CallError(stacktop,"tref: ~a is not a table", table, CONTINUABLE);
  302.   if (table->TABLE.comparator == Fn_eq)
  303.     ans = traverse_eq_table(stacktop, (struct table_structure*) table, key);
  304.   else
  305.     ans = traverse_table(stacktop, (struct table_structure*)table, key);
  306.   return ans;
  307. }
  308. EUFUN_CLOSE
  309.  
  310. LispObject insert_tree(LispObject *stacktop,struct table_structure* table,
  311.                LispObject key, LispObject value)
  312. {
  313.   LispObject node = nil, prev = nil;
  314.   int hashval, direction = 0;
  315.  
  316.   hashval = total_hash(key);
  317.   node = table->tree;
  318.   STACK_TMPV(table);
  319.   STACK_TMP(prev);
  320.   do {
  321.     LispObject tmp;
  322.  
  323.     if (null(node))
  324.       {        /* new node */
  325.     STACK_TMP(value);  STACK_TMP(key);
  326.     node = (LispObject)allocate_vector(stacktop,5);
  327.     UNSTACK_TMP(key);  TKEY(node) = key;
  328.     UNSTACK_TMP(value); TVALUE(node) = value;
  329.     STACK_TMP(node);
  330.     tmp = is_symbol(key) ? key->SYMBOL.lhash : allocate_integer(stacktop,hashval);
  331.     UNSTACK_TMP(node);
  332.     vref(node,2)=tmp;
  333.     TLEFT(node) = nil;
  334.     TRIGHT(node) = nil;
  335.     UNSTACK_TMP(prev);
  336.     if (prev == nil) 
  337.       {    /* new tree */
  338.         UNSTACK_TMP(tmp);
  339.         table= &tmp->TABLE;
  340.         table->tree = node;
  341.         return nil;
  342.       }
  343.     STACK_TMP(prev);
  344.     if (direction == 1)
  345.       {    /* should balance here */
  346.         TRIGHT(prev) = node;
  347.       }
  348.     else
  349.       {
  350.         TLEFT(prev) = node;
  351.       }
  352.     return nil;
  353.       }
  354.     if (hashval == THASH(node))
  355.       { 
  356.     STACK_TMP((LispObject)table);
  357.     STACK_TMP(key);
  358.     STACK_TMP(node);
  359.     STACK_TMP(value);
  360.     if (TCOMPARE(table,TKEY(node),key)) 
  361.       {
  362.         LispObject old;
  363.         UNSTACK_TMP(value);
  364.         UNSTACK_TMP(node);
  365.         old=TVALUE(node);    
  366.         TVALUE(node) = value;
  367.         return old;
  368.       }
  369.     UNSTACK_TMP(value);
  370.     UNSTACK_TMP(node);
  371.     UNSTACK_TMP(key);
  372.     UNSTACK_TMP(tmp);    
  373.     table=&(tmp->TABLE);
  374.       }
  375.     UNSTACK_TMP(prev);
  376.     prev = node;
  377.     STACK_TMP(prev);
  378.     if (hashval < THASH(node))
  379.       {
  380.     direction = -1;
  381.     node = TLEFT(node);
  382.       }
  383.     else 
  384.       {
  385.     direction = 1;
  386.     node = TRIGHT(node);
  387.       }
  388.   } while (TRUE);
  389.  
  390.   return(nil);
  391. }
  392.  
  393. EUFUN_3( tref_updator, table, key, value)
  394. {
  395.   LispObject old;
  396.  
  397.   KJPDBG(  fprintf( stderr, "\n'tref_updator' with table %lX ", table ) );
  398.   
  399.   while(!is_table(table))
  400.     table = CallError(stacktop,
  401.               "tref-updator: ~a is not a table", table, CONTINUABLE);
  402.   key = ARG_1(stackbase); value = ARG_2(stackbase);
  403.   old = insert_tree(stacktop, (struct table_structure*)table, key, value);
  404.  
  405.   return old;
  406. }
  407. EUFUN_CLOSE
  408.  
  409. EUFUN_2( map_table, node, proc)
  410. {
  411. /* proc was stacked by Fn_map_table, and node is accessible through
  412.  * the table. Thus this function should only be called from Fn_map_table.
  413.  */
  414.   if (!null(TLEFT(node)))
  415.     EUCALL_2(map_table,TLEFT(node), proc);
  416.   proc = ARG_1(stackbase);
  417.   node = ARG_0(stackbase);
  418.   EUCALL_3(apply2,proc,TKEY(node),TVALUE(node));
  419.   proc = ARG_1(stackbase);
  420.   node = ARG_0(stackbase);
  421.  
  422.   stacktop = stackbase;
  423.   if (!null(TRIGHT(node)))
  424.     EUCALL_2(map_table, TRIGHT(node), proc);
  425.   return nil;
  426. }
  427. EUFUN_CLOSE
  428.  
  429. EUFUN_2( Fn_map_table, proc, table)
  430. {
  431.   LispObject node = nil;
  432.  
  433.   while (!is_table(table))
  434.     table = CallError(stacktop,
  435.               "map-table: ~a is not a table", table, CONTINUABLE);
  436.   ARG_1(stackbase) = table;
  437.   proc = ARG_0(stackbase);
  438.   while (!is_function(proc))
  439.     proc = CallError(stacktop,
  440.              "map-table: ~a is not a function", proc, CONTINUABLE);
  441.   table = ARG_1(stackbase);
  442.   node = (table->TABLE).tree;
  443.   if (!null(node)) {
  444.     STACK_TMP(node);
  445.     EUCALL_3(apply2,ARG_0(stackbase)/*proc*/,TKEY(node),TVALUE(node));
  446.     UNSTACK_TMP(node);
  447.     STACK_TMP(node);
  448.     if (!null(TLEFT(node)))
  449.       EUCALL_2(map_table, TLEFT(node), ARG_0(stackbase)/*proc*/);
  450.     UNSTACK_TMP(node);
  451.     if (!null(TRIGHT(node)))
  452.       EUCALL_2(map_table, TRIGHT(node), ARG_0(stackbase)/*proc*/);
  453.   }
  454.   return nil;
  455. }
  456. EUFUN_CLOSE
  457.  
  458. void table_copy_aux(LispObject *stacktop, LispObject node, LispObject new)
  459. {
  460. /*  LispObject node; */
  461. /*  node = old->TABLE.tree; */
  462.   if (!null(node)) {
  463.     fprintf(stderr, "copying "); 
  464.     STACK_TMP(new);
  465.     STACK_TMP(node);
  466.     EUCALL_2(Fn_print, TKEY(node), NULL);
  467.     UNSTACK_TMP(node);
  468.     STACK_TMP(node);
  469.     EUCALL_2(Fn_print, TVALUE(node), NULL);
  470.     UNSTACK_TMP(node);
  471.     UNSTACK_TMP(new);
  472.     STACK_TMP(new);
  473.     STACK_TMP(node);
  474.     EUCALL_3(tref_updator, new, TKEY(node), TVALUE(node));
  475.     KJPDBG( fprintf( stderr, "Tref updated the new table\n" ) );
  476.     if (!null(TLEFT(node))) {
  477.       UNSTACK_TMP(node);
  478.       UNSTACK_TMP(new);
  479.       STACK_TMP(new);
  480.       STACK_TMP(node);
  481.       table_copy_aux(stacktop,TLEFT(node), new);
  482.       UNSTACK_TMP(node);
  483.       UNSTACK_TMP(new);
  484.       STACK_TMP(new);
  485.       STACK_TMP(node);
  486.     }
  487.     if (!null(TRIGHT(node))) {
  488.       UNSTACK_TMP(node);
  489.       UNSTACK_TMP(new);
  490.       table_copy_aux(stacktop,TRIGHT(node), new);
  491.     }
  492.   }
  493.   return;
  494. }
  495.  
  496. EUFUN_1( table_copy, table)
  497. {
  498.   LispObject ans;
  499.  
  500.   ans = (LispObject) allocate_table(stacktop,table->TABLE.comparator);
  501.   ans->TABLE.lisp_comparator = table->TABLE.lisp_comparator;
  502.  
  503.   table_copy_aux(stacktop,table->TABLE.tree, ans);
  504.  
  505.   return ans;
  506. }
  507. EUFUN_CLOSE
  508.  
  509. EUFUN_1( Fn_clear_table, table)
  510. {
  511.   while (!is_table(table))
  512.     table = CallError(stacktop,"clear-table: ~a is not a table", table,
  513.               CONTINUABLE);
  514.   table->TABLE.tree = nil;
  515.   return table;
  516. }
  517. EUFUN_CLOSE
  518.  
  519. /* This function is not used by anyone!!!
  520. void put_table(LispObject *stacktop, LispObject tab1, LispObject tab2 )
  521. {
  522.   if ( tab1 == nil )
  523.     return;
  524.   else
  525.     table_copy_aux(stacktop,tab1->TABLE.tree, tab2);
  526. }
  527. */
  528.  
  529. /* Printing... */
  530.  
  531. EUFUN_2( Md_generic_prin_Table, tab, stream)
  532. {
  533.   extern LispObject Gf_generic_prin(LispObject*);
  534.  
  535.   if (!is_stream(stream))
  536.     CallError(stacktop,
  537.           "generic-prin: non-stream argument",stream,NONCONTINUABLE);
  538.  
  539.   /* We assume the table's what it claims to be... */
  540.  
  541.   if (tab->TABLE.comparator == NULL) {
  542.     fprintf(stream->STREAM.handle,"#T(comparator: ");
  543.     EUCALL_2(Gf_generic_prin,tab->TABLE.lisp_comparator,stream);
  544.     stream = ARG_1(stackbase);
  545.     fprintf(stream->STREAM.handle,")");
  546.   }
  547.   else {
  548.     if (tab->TABLE.comparator == Fn_eq)
  549.       fprintf(stream->STREAM.handle,"#T(eq)");
  550.     else
  551.       fprintf(stream->STREAM.handle,"#T(equal)");
  552.   }
  553.  
  554.   return(tab);
  555. }
  556. EUFUN_CLOSE
  557.  
  558. /* Writing... */
  559.  
  560. EUFUN_2( Md_generic_write_Table, tab, stream)
  561. {
  562.   extern LispObject Gf_generic_prin(LispObject*);
  563.  
  564.   if (!is_stream(stream))
  565.     CallError(stacktop,
  566.           "generic-write: non-stream argument",stream,NONCONTINUABLE);
  567.  
  568.   /* We assume the table's what it claims to be... */
  569.  
  570.   if (tab->TABLE.comparator == NULL) {
  571.     fprintf(stream->STREAM.handle,"#T(comparator: ");
  572.     EUCALL_2(Gf_generic_prin,tab->TABLE.lisp_comparator,stream);
  573.     stream = ARG_1(stackbase);
  574.     fprintf(stream->STREAM.handle,")");
  575.   }
  576.   else {
  577.     if (tab->TABLE.comparator == Fn_eq)
  578.       fprintf(stream->STREAM.handle,"#T(eq)");
  579.     else
  580.       fprintf(stream->STREAM.handle,"#T(equal)");
  581.   }
  582.  
  583.   return(tab);
  584. }
  585. EUFUN_CLOSE
  586.  
  587. void initialise_tables(LispObject *stacktop)
  588. {
  589.   LispObject fun, upd;
  590.  
  591.   open_module(stacktop,
  592.           &Module_tables,
  593.           Module_tables_values,
  594.           "tables",
  595.           TABLES_ENTRIES);
  596.  
  597.   (void) make_module_function(stacktop,"tablep",Fn_tablep,1);
  598.   (void) make_module_function(stacktop,"make-table",Fn_make_table,-1);
  599.   (void) make_module_function(stacktop,"table-parameters",Fn_table_parameters,1);
  600.   fun = make_module_function(stacktop,"table-ref",Fn_tref,2);
  601.   STACK_TMP(fun);
  602.   upd = make_unexported_module_function(stacktop,"table-ref-updator", tref_updator, 3);
  603.   UNSTACK_TMP(fun);
  604.   set_anon_associate(stacktop,fun, upd);
  605.  
  606.   (void) make_module_function(stacktop,"map-table",Fn_map_table,2);
  607.   (void) make_module_function(stacktop,"copy-table", table_copy, 1);
  608.  
  609.   (void) make_module_function(stacktop,"table-keys",Fn_table_keys,1);
  610.   (void) make_module_function(stacktop,"clear-table",Fn_clear_table,1);
  611.  
  612.   make_module_function(stacktop,"generic_generic_prin,Table",Md_generic_prin_Table,2);
  613.   make_module_function(stacktop,"generic_generic_write,Table",Md_generic_write_Table,2);
  614.   
  615.   close_module();
  616. }
  617.